home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / ODE / utils < prev   
Encoding:
Text File  |  1991-10-24  |  2.9 KB  |  148 lines
  1. \ General Utilities to support JForth & HMSL
  2. \ These utilities are useful words which are not likely to be
  3. \ supported by a typical Forth.  Words which some Forths support
  4. \ but some not, should be defined in XXX_BASE.
  5. \
  6. \ Author: Phil Burk
  7. \ Copyright 1986
  8. \
  9. \ MOD: PLB 11/9/86 Add SERVICE.TASKS/16
  10. \ MOD: PLB 3/2/87 Use abort" in stack.check.
  11. \ MOD: PLB 4/29/87 Remove include? , change V: to VARIABLE
  12. \ MOD: PLB 9/3/87 Add DEBUG.TYPE
  13. \ MOD: PLB 5/17/91 Merged with ho:more_utils
  14.  
  15. include? toupper ju:char-macros
  16.  
  17. ANEW TASK-UTILS
  18.  
  19. VARIABLE IF-DEBUG   ( debug trace flag )
  20. VARIABLE IF-TESTING ( flag for loading test code )
  21.  
  22. : DEBUG.TYPE ( $string -- , type if debugging )
  23.     if-debug @
  24.     IF >newline count type space
  25.     ELSE drop
  26.     THEN
  27. ;
  28.  
  29. .NEED <=
  30. : <=  ( a b -- flag )
  31.     > not
  32. ;
  33. : >=  ( a b -- flag )
  34.     < not
  35. ;
  36. .THEN
  37.  
  38. : ?MORE   ( count -- flag , pause every 20, true if "Q")
  39.     20 mod 0=     dup
  40.     IF drop
  41.         ." Q to quit, <CR> to continue ----" CR
  42.         KEY ascii q =
  43.     THEN
  44. ;
  45.  
  46.  
  47. \ Stack depth checking , useful for catching leftovers --------
  48. VARIABLE STACK-HOLD
  49. : STACK.MARK  ( -- , record depth of stack )
  50.     depth stack-hold !
  51. ;
  52. : STACK.CHECK  ( -- , check to make sure stack hasn't been damaged )
  53.     depth stack-hold @ = NOT
  54.     IF  ." Old stack depth = " stack-hold @ .
  55.         .s
  56.         true abort" STACK.CHECK - Change in stack depth!"
  57.     THEN
  58. ;
  59.  
  60.  
  61. : $EQUAL  ( $string1 $string2 -- true_if_= , case insens. )
  62.     >r count
  63.     r> count 2 pick =
  64.     IF text=?
  65.     ELSE
  66.         2drop drop false
  67.     THEN
  68. ;
  69.  
  70.  
  71. hex
  72. : NFA.MOVE ( nfa addr -- , copy name field to address and fix like string )
  73.     >r count 1f and ( n+1 c ,  remove immediate bit )
  74.     dup r@ c! ( set length at pad )
  75.     r> 1+ rot rot 0 ( a+1 n+1 c 0 )
  76.     DO
  77.         2dup c@ 7f and  ( remove flags from characters )
  78.         swap c!
  79.         1+ swap 1+ swap ( advance )
  80.     LOOP 2drop
  81. ;
  82.  
  83. : NFA->$ ( nfa -- $string , copy to pad )
  84.     pad nfa.move pad
  85. ;
  86. decimal
  87.  
  88. \ Assistance for debugging.
  89. : BREAK ( -- , dump stack and allow abort )
  90.     .s cr ." BREAK - Enter A to abort" cr
  91.     key toupper ascii A =
  92.     IF abort THEN
  93. ;
  94.  
  95. : BREAK" ( xxxx" -- , give message and break )
  96.     [compile] ."
  97.     compile break
  98. ; immediate
  99.  
  100. \ ?terminal that only happens so often to avoid slowing down system
  101. V: ?term-count
  102. : ?TERMINAL/64  ( -- key? , true if key pressed, sometimes )
  103.     ?term-count @ dup
  104.     1+ 63 AND ?term-count !
  105.     0= IF ?terminal
  106.     ELSE false
  107.     THEN
  108. ;
  109. : ?TERMINAL/8  ( -- key? , true if key pressed, sometimes )
  110.     ?term-count @ dup
  111.     1+ 7 AND ?term-count !
  112.     0= IF ?terminal
  113.     ELSE false
  114.     THEN
  115. ;
  116.  
  117. \ Range checking and clipping tools.
  118. : INRANGE? ( n lo hi -- flag , Is LO <= N <= HI ? )
  119.     2 pick <
  120.     IF 2drop false
  121.     ELSE >=
  122.     THEN
  123. ;
  124.  
  125. : CLIPTO ( n lo hi -- nclipped , clip N to range )
  126.     >r max r> min
  127. ;
  128.  
  129. : BAD.CHAR? ( CHAR -- FLAG , true if non printing)
  130.     32 126 inrange? not
  131. ;
  132.  
  133. : SAFE.EMIT ( char -- , emit if safe or '.' )
  134.     dup bad.char?
  135.     IF drop ascii . emit
  136.     ELSE emit
  137.     THEN
  138. ;
  139.  
  140. : BAD.STR? ( addr count -- , scan string for bad chars)
  141.     0
  142.     DO  dup i + c@ bad.char?
  143.         IF  cr dup i + dup h. c@ h.
  144.         THEN
  145.     LOOP drop
  146. ;
  147.  
  148.